Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/himetr1r/ctlbookm.ctl

Text File | 1999-08-14 | 22.5 KB | 725 lines

VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.UserControl ctlFavourites
   ClientHeight    =   2415
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3165
   BeginProperty Font
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ScaleHeight     =   2415
   ScaleWidth      =   3165
   Begin VB.PictureBox picTabContainer
      Height          =   1695
      Index           =   3
      Left            =   1080
      ScaleHeight     =   1635
      ScaleWidth      =   3315
      TabIndex        =   7
      Top             =   3480
      Width           =   3375
      Begin ComctlLib.ListView lvSort
         Height          =   855
         Left            =   0
         TabIndex        =   9
         Top             =   360
         Width           =   2895
         _ExtentX        =   5106
         _ExtentY        =   1508
         View            =   3
         LabelEdit       =   1
         LabelWrap       =   -1  'True
         HideSelection   =   0   'False
         _Version        =   327682
         ForeColor       =   -2147483640
         BackColor       =   -2147483643
         BorderStyle     =   1
         Appearance      =   1
         NumItems        =   1
         BeginProperty ColumnHeader(1) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
            Key             =   ""
            Object.Tag             =   ""
            Text            =   "Description"
            Object.Width           =   2540
         EndProperty
      End
      Begin VB.Label lblSort
         BackColor       =   &H8000000C&
         Caption         =   "Sort by Version: 5"
         BeginProperty Font
            Name            =   "Tahoma"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H8000000E&
         Height          =   255
         Left            =   0
         TabIndex        =   8
         Top             =   0
         Width           =   2895
      End
   End
   Begin VB.PictureBox picTabContainer
      Height          =   1815
      Index           =   2
      Left            =   600
      ScaleHeight     =   1755
      ScaleWidth      =   3555
      TabIndex        =   4
      Top             =   3120
      Width           =   3615
      Begin ComctlLib.ListView lvFindResults
         Height          =   975
         Left            =   0
         TabIndex        =   6
         Top             =   360
         Width           =   3135
         _ExtentX        =   5530
         _ExtentY        =   1720
         View            =   3
         LabelEdit       =   1
         LabelWrap       =   -1  'True
         HideSelection   =   0   'False
         _Version        =   327682
         ForeColor       =   -2147483640
         BackColor       =   -2147483643
         BorderStyle     =   1
         Appearance      =   1
         NumItems        =   1
         BeginProperty ColumnHeader(1) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
            Key             =   ""
            Object.Tag             =   ""
            Text            =   "Description"
            Object.Width           =   2540
         EndProperty
      End
      Begin VB.Label lblFindResults
         BackColor       =   &H8000000C&
         Caption         =   "Find Results:"
         BeginProperty Font
            Name            =   "Tahoma"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H8000000E&
         Height          =   255
         Left            =   0
         TabIndex        =   5
         Top             =   0
         Width           =   3135
      End
   End
   Begin VB.PictureBox picTabContainer
      Height          =   1695
      Index           =   1
      Left            =   120
      ScaleHeight     =   1635
      ScaleWidth      =   3195
      TabIndex        =   1
      Top             =   2640
      Width           =   3255
      Begin ComctlLib.ListView lvFavourites
         Height          =   1095
         Left            =   0
         TabIndex        =   3
         Top             =   360
         Width           =   3015
         _ExtentX        =   5318
         _ExtentY        =   1931
         View            =   3
         LabelEdit       =   1
         LabelWrap       =   -1  'True
         HideSelection   =   0   'False
         _Version        =   327682
         ForeColor       =   -2147483640
         BackColor       =   -2147483643
         BorderStyle     =   1
         Appearance      =   1
         NumItems        =   2
         BeginProperty ColumnHeader(1) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
            Key             =   ""
            Object.Tag             =   ""
            Text            =   "Description"
            Object.Width           =   2540
         EndProperty
         BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
            SubItemIndex    =   1
            Key             =   ""
            Object.Tag             =   ""
            Text            =   "Section"
            Object.Width           =   2540
         EndProperty
      End
      Begin VB.Label lblFavourites
         BackColor       =   &H8000000C&
         Caption         =   "Favourites:"
         BeginProperty Font
            Name            =   "Tahoma"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H8000000E&
         Height          =   255
         Left            =   0
         TabIndex        =   2
         Top             =   0
         Width           =   3015
      End
   End
   Begin ComctlLib.TabStrip tbsTab
      Height          =   2415
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   3135
      _ExtentX        =   5530
      _ExtentY        =   4260
      ImageList       =   "ImageList1"
      _Version        =   327682
      BeginProperty Tabs {0713E432-850A-101B-AFC0-4210102A8DA7}
         NumTabs         =   3
         BeginProperty Tab1 {0713F341-850A-101B-AFC0-4210102A8DA7}
            Caption         =   "Favourites"
            Key             =   ""
            Object.Tag             =   ""
            Object.ToolTipText     =   "Favourites"
            ImageVarType    =   8
            ImageKey        =   "FAVS"
         EndProperty
         BeginProperty Tab2 {0713F341-850A-101B-AFC0-4210102A8DA7}
            Caption         =   "Find Results"
            Key             =   ""
            Object.Tag             =   ""
            Object.ToolTipText     =   "Find Results"
            ImageVarType    =   8
            ImageKey        =   "FIND"
         EndProperty
         BeginProperty Tab3 {0713F341-850A-101B-AFC0-4210102A8DA7}
            Caption         =   "Sort"
            Key             =   ""
            Object.Tag             =   ""
            Object.ToolTipText     =   "Sort"
            ImageVarType    =   8
            ImageKey        =   "SORT"
         EndProperty
      EndProperty
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin ComctlLib.ImageList ImageList1
      Left            =   3720
      Top             =   1560
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483637
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      UseMaskColor    =   0   'False
      _Version        =   327682
      BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7}
         NumListImages   =   3
         BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
            Picture         =   "ctlBookmark.ctx":0000
            Key             =   "FIND"
         EndProperty
         BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
            Picture         =   "ctlBookmark.ctx":031A
            Key             =   "FAVS"
         EndProperty
         BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
            Picture         =   "ctlBookmark.ctx":2ACE
            Key             =   "SORT"
         EndProperty
      EndProperty
   End
End
Attribute VB_Name = "ctlFavourites"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'----------------------------------------
'- Name: Sam Huggill
'- Email: [e-mail]
'- Web: http://www.vbsquare.com/
'- Company: Lighthouse Internet Solutions
'- Date/Time: 14/08/99 11:28:38
'----------------------------------------
'- Notes:   Handles bookmarks, find results
'           and sorting
'----------------------------------------

Option Explicit

Private Const NumberOfTabs = 3

Private WithEvents m_cMenu As cPopupMenu
Attribute m_cMenu.VB_VarHelpID = -1


Private Sub lvFavourites_ColumnClick(ByVal ColumnHeader As ComctlLib.ColumnHeader)
    '// Sort the items
    lvFavourites.SortKey = ColumnHeader.Index - 1
    lvFavourites.Sorted = True
End Sub

Private Sub lvFavourites_ItemClick(ByVal Item As ComctlLib.ListItem)
    Dim strKey As String
    Dim nodNode As Node

    On Error Resume Next

    strKey = Item.Key

    If frmMain.tvwItems.Nodes(strKey) Is Nothing Then Exit Sub

    Set nodNode = frmMain.tvwItems.Nodes(strKey)
    If Not (nodNode Is Nothing) Then
        nodNode.EnsureVisible
        nodNode.Selected = True
        modData.SelectItem nodNode.Key, frmMain.ctlData1
    End If

    Set nodNode = Nothing
End Sub

Private Sub lvFavourites_KeyUp(KeyCode As Integer, Shift As Integer)
    Dim lngRet As Long

    If KeyCode = vbKeyDelete Then
        lngRet = MsgBox("Are you sure you want to delete this favourite?", vbExclamation + vbYesNo)
        If lngRet = vbYes Then
            modData.DeleteFavourite lvFavourites, lvFavourites.SelectedItem.Key
        End If
    End If
End Sub

Private Sub lvFavourites_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim intIndex As Integer
    Dim blnSelected As Boolean

    If lvFavourites.SelectedItem Is Nothing Then
        blnSelected = False
    Else
        blnSelected = True
    End If

    If Button = vbRightButton Then
        m_cMenu.Restore "Favourites"
        m_cMenu.Enabled(m_cMenu.IndexForKey("DELETE")) = blnSelected
        intIndex = m_cMenu.ShowPopupMenu(X + lvFavourites.left, Y + lvFavourites.tOp)
    End If
End Sub

Private Sub lvFindResults_ItemClick(ByVal Item As ComctlLib.ListItem)
    Dim strKey As String
    Dim nodNode As Node

    strKey = Item.Key

    Set nodNode = frmMain.tvwItems.Nodes(strKey)
    If Not (nodNode Is Nothing) Then
        nodNode.EnsureVisible
        nodNode.Selected = True
        modData.SelectItem strKey, frmMain.ctlData1
    End If

    Set nodNode = Nothing
End Sub

Private Sub lvSort_ItemClick(ByVal Item As ComctlLib.ListItem)
    Dim strKey As String
    Dim nodNode As Node

    strKey = Item.Key

    Set nodNode = frmMain.tvwItems.Nodes(strKey)
    If Not (nodNode Is Nothing) Then
        nodNode.EnsureVisible
        nodNode.Selected = True
        modData.SelectItem strKey, frmMain.ctlData1
    End If

    Set nodNode = Nothing
End Sub

Private Sub lvSort_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim intIndex As Integer

    If Button = vbRightButton Then
        m_cMenu.Restore "Sort"
        m_cMenu.RemoveItem "DELETE"
        intIndex = m_cMenu.ShowPopupMenu(X + lvSort.left, Y + lvSort.tOp)
    End If
End Sub

Private Sub m_cMenu_Click(ItemNumber As Long)
    Select Case m_cMenu.ItemKey(ItemNumber)

        Case "DELETE"
            lvFavourites_KeyUp vbKeyDelete, 0
        Case "Version"
            frmSort.Caption = "Sort by Version"

            With frmSort.cboData
                .Clear
                .AddItem "VB4 16"
                .AddItem "VB4 32"
                .AddItem "VB5"
                .AddItem "VB6"
                .ListIndex = 0
            End With

            frmSort.Show vbModal
        Case "Level"
            frmSort.Caption = "Sort by Level"

            With frmSort.cboData
                .Clear
                .AddItem "Beginner"
                .AddItem "Intermediate"
                .AddItem "Advanced"
                .ListIndex = 0
            End With

            frmSort.Show vbModal
        Case Else
    End Select
End Sub

Private Sub tbsTab_Click()
    Static PrevTab As Integer

    PrevTab = Switch(PrevTab = 0, 1, PrevTab >= 1 And PrevTab <= NumberOfTabs, PrevTab)

    picTabContainer(PrevTab).Visible = False
    picTabContainer(tbsTab.SelectedItem.Index).Visible = True
    picTabContainer(tbsTab.SelectedItem.Index).Refresh
    PrevTab = tbsTab.SelectedItem.Index
    DoEvents

End Sub

Private Sub UserControl_Resize()
    With tbsTab
        .Move UserControl.ScaleLeft, UserControl.ScaleTop, UserControl.ScaleWidth, UserControl.ScaleHeight
    End With

    With picTabContainer(1)
        .tOp = tbsTab.ClientTop
        .Width = tbsTab.ClientWidth
        .left = tbsTab.ClientLeft
        .Height = tbsTab.ClientHeight
        .Move .left, .tOp, .Width, .Height
    End With

    With picTabContainer(2)
        .tOp = tbsTab.ClientTop
        .Width = tbsTab.ClientWidth
        .left = tbsTab.ClientLeft
        .Height = tbsTab.ClientHeight
        .Move .left, .tOp, .Width, .Height
    End With

    With picTabContainer(3)
        .tOp = tbsTab.ClientTop
        .Width = tbsTab.ClientWidth
        .left = tbsTab.ClientLeft
        .Height = tbsTab.ClientHeight
        .Move .left, .tOp, .Width, .Height
    End With

    With lblFavourites
        .Move ScaleLeft + 15, ScaleTop + 15, tbsTab.ClientWidth - 30, .Height
    End With

    With tbsTab
        lvFavourites.Move ScaleLeft + 15, lblFavourites.Height + 15, .ClientWidth - lvFavourites.left, .ClientHeight - lblFavourites.Height
        lvFindResults.Move ScaleLeft + 15, lblFindResults.Height + 15, .ClientWidth - lvFindResults.left, .ClientHeight - lblFindResults.Height
        lvSort.Move ScaleLeft + 15, lblSort.Height + 15, .ClientWidth - lvSort.left, .ClientHeight - lblSort.Height
    End With

    With lblFindResults
        .Move ScaleLeft + 15, ScaleTop + 15, tbsTab.ClientWidth - 30, .Height
    End With

    With lblFavourites
        .Move ScaleLeft + 15, ScaleTop + 15, tbsTab.ClientWidth - 30, .Height
    End With

    With lblSort
        .Move ScaleLeft + 15, ScaleTop + 15, tbsTab.ClientWidth - 30, .Height
    End With

End Sub

Public Sub AutoSizeLastColumn(lvListView As ListView)
    Dim lCount As Long
    Dim lNoColumns As Long
    Dim lTotSize As Long
    Dim lRet As Long
    Dim lSize As Long
    Dim lHScrollBarWidth As Long

    '
    ' Get Number of columns in this listview
    '
    lNoColumns = lvListView.ColumnHeaders.Count
    '
    ' Get ScrollBar Width
    '
    lHScrollBarWidth = GetSystemMetrics(SM_CXVSCROLL)

    For lCount = 0 To lNoColumns - 2
        '
        ' Get the total size of all the columns except the last one we want to resize
        '
        lSize = SendMessageLong(lvListView.hwnd, LVM_GETCOLUMNWIDTH, lCount, 0)
        lTotSize = lTotSize + lSize
    Next
    '
    ' Now determine how big to make the last columm in pixels
    '

    lSize = (lvListView.Width / Screen.TwipsPerPixelX) - (lTotSize + lHScrollBarWidth + 10)
    '
    ' Now set the column width
    '
    SendMessageLong lvListView.hwnd, LVM_SETCOLUMNWIDTH, lNoColumns - 1, lSize

End Sub

Sub Initalize()
    Dim strSort As String
    Dim strValue As String
    Dim intX As Integer
    Dim blnTab As Boolean
    Dim intTabIndex As Integer

    On Error GoTo vbErrHand

    For intX = 1 To NumberOfTabs
        With picTabContainer(intX)
            .BorderStyle = 0
            .left = tbsTab.ClientLeft
            .tOp = tbsTab.ClientTop
            .Width = tbsTab.ClientWidth
            .Height = tbsTab.ClientHeight
            .Visible = False
        End With
    Next intX

    modData.LoadBookmarks lvFavourites

    AutoSizeLastColumn lvFavourites
    AutoSizeLastColumn lvFindResults
    SetControl

    '// Setup the popup menu
    Set m_cMenu = New cPopupMenu
    With m_cMenu
        .ImageList = frmMain.ilsMenu
        .hwndOwner = UserControl.hwnd
        .GradientHighlight = True
        .Clear

        .AddItem "&Delete Favourite", , , , 14, , , "DELETE"
        .Store "Favourites"

        .AddItem "Sort by &Version", , , , 26, , , "Version"
        .AddItem "Sort by &Level", , , , 26, , , "Level"
        .Store "Sort"
    End With

    strSort = GetSetting(ThisApp, "General", "Sort Type", "Version")
    strValue = GetSetting(ThisApp, "General", "Sort Value", "5")
    lblSort = modData.SortBy(strSort, strValue, lvSort)

    blnTab = GetSetting(ThisApp, "General", "Remember Tabs", True)
    If blnTab Then
        intTabIndex = Val(GetSetting(ThisApp, "General", "Control Panel", 1))

        '// Thanks to Randy Ledyard
        If intTabIndex = 0 Then intTabIndex = 1

        tbsTab.Tabs(intTabIndex).Selected = True
    End If

    '    SetBkImage lvFavourites
    '    SetBkImage lvFindResults
    '    SetBkImage lvSort

    FlatHeader lvFavourites
    FlatHeader lvFindResults
    FlatHeader lvSort

    HeaderTrackSelect lvFavourites
    HeaderTrackSelect lvFindResults
    HeaderTrackSelect lvSort

    Exit Sub

vbErrHand:
    WriteError Err.Number, Err.Description, "ctlFavs:Init", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "ctlFavs:Init"


End Sub

Sub SetControl()
    Dim lStyle As Long
    Dim lHeaderHWND As Long
    Dim lLVHwnd As Long
    Dim lCount As Long

    lLVHwnd = lvFavourites.hwnd
    SendMessageLong lLVHwnd, LVM_SETEXTENDEDLISTVIEWSTYLE, LVS_EX_FULLROWSELECT, True

    lLVHwnd = lvFindResults.hwnd
    SendMessageLong lLVHwnd, LVM_SETEXTENDEDLISTVIEWSTYLE, LVS_EX_FULLROWSELECT, True

    lLVHwnd = lvSort.hwnd
    SendMessageLong lLVHwnd, LVM_SETEXTENDEDLISTVIEWSTYLE, LVS_EX_FULLROWSELECT, True

    '
    ' Turn off Redrawing at this point to speed up / hide the visible changes
    '

    SendMessageLong lvFavourites.hwnd, WM_SETREDRAW, False, &O0
    SendMessageLong lvFindResults.hwnd, WM_SETREDRAW, False, &O0
    SendMessageLong lvSort.hwnd, WM_SETREDRAW, False, &O0

    For lCount = 0 To lvFavourites.ColumnHeaders.Count - 1
        Call SendMessageLong(lvFavourites.hwnd, LVM_SETCOLUMNWIDTH, lCount, ByVal LVSCW_AUTOSIZE_USEHEADER)
    Next

    For lCount = 0 To lvFindResults.ColumnHeaders.Count - 1
        Call SendMessageLong(lvFindResults.hwnd, LVM_SETCOLUMNWIDTH, lCount, ByVal LVSCW_AUTOSIZE_USEHEADER)
    Next

    For lCount = 0 To lvSort.ColumnHeaders.Count - 1
        Call SendMessageLong(lvSort.hwnd, LVM_SETCOLUMNWIDTH, lCount, ByVal LVSCW_AUTOSIZE_USEHEADER)
    Next
    '
    ' Turn Redrawing back on
    '
    SendMessageLong lvFavourites.hwnd, WM_SETREDRAW, True, &O0
    SendMessageLong lvFindResults.hwnd, WM_SETREDRAW, True, &O0
    SendMessageLong lvSort.hwnd, WM_SETREDRAW, True, &O0
End Sub

Sub SelectTab(intTab As Integer)
    tbsTab.Tab = intTab
End Sub

Sub Sort(frm As Object)
    If frm.Caption = "Sort by Version" Then
        lblSort = modData.SortBy("Version", Right$(frm.cboData.Text, Len(frm.cboData.Text) - 2), lvSort)
    End If

    If frm.Caption = "Sort by Level" Then
        lblSort = modData.SortBy("Level", frm.cboData.Text, lvSort)
    End If

End Sub

Public Sub AddFindRes(strText As String, strKey As String)
    lvFindResults.ListItems.Add , strKey, strText
    SetControl
End Sub

Public Sub AddItem(tvw As TreeView)
    modData.Key = tvw.SelectedItem.Key
    modData.AddFavourite tvw, lvFavourites
End Sub

Public Sub Terminate()
    If Not (m_cMenu Is Nothing) Then
        m_cMenu.Clear
        m_cMenu.DestroySubClass
    End If

    Set m_cMenu = Nothing
    modData.SaveSort lblSort, tbsTab.SelectedItem.Index, lvSort
End Sub

Public Sub DeleteItem(tvw As TreeView)
    modData.DeleteFavourite lvFavourites, tvw.SelectedItem.Key
End Sub

Sub ClearFindRes()

    lvFindResults.ListItems.Clear

End Sub

Public Function ListCount() As Integer
    ListCount = lvFindResults.ListItems.Count
End Function

Public Sub ShowFindTab()
    tbsTab.Tabs(2).Selected = True
End Sub

Private Sub SetBkImage(lv As ListView)
    Dim tLBI As LVBKIMAGE
    Dim strPath As String
    strPath = App.Path & "\back.gif"
    tLBI.pszImage = strPath & Chr$(0)
    tLBI.cchImageMax = Len(strPath) + 1
    tLBI.ulFlags = LVBKIF_SOURCE_URL Or LVBKIF_STYLE_TILE
    SendMessage lv.hwnd, LVM_SETBKIMAGE, 0, tLBI
    SendMessageByLong lv.hwnd, LVM_SETTEXTBKCOLOR, 0, CLR_NONE
End Sub

Private Sub FlatHeader(lv As ListView)
    Dim lngHwnd As Long
    Dim lngStyle As Long

    lngHwnd = SendMessageByLong(lv.hwnd, LVM_GETHEADER, 0, 0)
    If lngHwnd <> 0 Then
        lngStyle = GetWindowLong(lngHwnd, GWL_STYLE)
        lngStyle = lngStyle And Not HDS_BUTTONS
        SetWindowLong lngHwnd, GWL_STYLE, lngStyle
    End If
End Sub

Private Sub HeaderTrackSelect(lv As ListView)
    Dim lngHwnd As Long
    Dim lngStyle As Long

    lngHwnd = SendMessageByLong(lv.hwnd, LVM_GETHEADER, 0, 0)
    If lngHwnd <> 0 Then
        lngStyle = GetWindowLong(lngHwnd, GWL_STYLE)
        lngStyle = lngStyle Or HDS_HOTTRACK
        SetWindowLong lngHwnd, GWL_STYLE, lngStyle
    End If
End Sub